home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / linker.t < prev    next >
Text File  |  1989-06-30  |  23KB  |  557 lines
  1. (herald linker
  2.   (env t (link defs))); (osys load_comex)))
  3.  
  4. ;;; This is all straightforward except for the 'linker magic'  i.e. the
  5. ;;; bootstrap symbols.  These are variables which are needed by the image
  6. ;;; being built (referenced in modules being linked) but which cannot be
  7. ;;; defined in any single module.  After all other references have been resolved
  8. ;;; the linker pretends that these variables have been defined by filling
  9. ;;; the references with its own data structures.
  10.  
  11. (import t-implementation-env make-table-with-size iob? vm-write-char
  12.     read-comex-from-file symbol-length symbol-hash %%symbol-text-offset
  13.     double-float?)
  14.     
  15.  
  16.  
  17. (define-local-syntax (dotimes spec . body)
  18.   (let ((index (car spec))
  19.         (limit (cadr spec)))
  20.     `(do ((,index 0 (fx+ ,index 1)))
  21.          ((fx= ,index ,limit))
  22.        ,@body)))
  23.  
  24. (lset *null-descriptor* nil)
  25. (lset *symbols* nil)          
  26. (lset *boot-env* nil)
  27. (lset *lstate* nil)
  28. (lset *var-table* nil)
  29. (lset *reloc-table* nil)
  30. (lset *linker-noise-file* nil)
  31.  
  32. (define (really-link modules obj-type out-spec out-type)                                             
  33.   (linker-message "~&Linking ~a ... ~%" out-spec)
  34.   (bind ((*null-descriptor* nil)
  35.          (*symbols* '())
  36.          (*boot-env* '())
  37.          (*lstate* (create-lstate))
  38.          (*var-table* (make-table-with-size 2000 'linker-var-table))
  39.          (*reloc-table* (make-table-with-size 16000 'linker-reloc-table)))
  40.     (let ((comex-list 
  41.            (map (lambda (file) 
  42.                   (read-comex-from-file (filename-with-type (->filename file) 
  43.                                                             obj-type)))
  44.                 modules)))
  45.       (linker-message "~&resolving modules~%")
  46.       (let* ((units (linker-resolve comex-list))
  47.              (unit-vec (list->vector units))
  48.              (filename (->filename out-spec)))
  49.         (define-null-descriptor (lstate-impure *lstate*))
  50.         (relocate-units units unit-vec)
  51.         (patch-in-definitions unit-vec 
  52.                               (map cons (map comex-code comex-list) units))
  53.         (with-open-ports 
  54.          ((image (open (filename-with-type filename out-type) '(out)))
  55.           (map  (open (filename-with-type filename 'map) '(out))))
  56.          (linker-message "~&writing object file~%")
  57.          (set (lstate-pure-size *lstate*) 
  58.               (area-frontier (lstate-pure *lstate*)))
  59.          (table-walk *var-table* 
  60.                      (lambda (name node)
  61.                        (cond ((not (var-node-defined node))
  62.                               (warning "undefined global ~S" name))
  63.                              (else
  64.                               (write-map-entry map name (var-node-value node))))))
  65.          (write-link-file image)
  66.          *lstate*)))))
  67.  
  68. (define (linker-resolve comi)
  69.   (do ((comi comi (cdr comi))
  70.        (units '() (cons (instantiate-comex (car comi)) units)))
  71.       ((null? comi)
  72.        (reverse! units))))
  73.  
  74. (define (instantiate-comex comex)
  75.   (let* ((objects (comex-objects comex))
  76.          (opcodes (comex-opcodes comex))
  77.          (code (comex-code comex))
  78.          (unit-len (vector-length objects))
  79.          (unit (make-vector (fx+ unit-len 1))))
  80.     (do ((i 1 (fx+ i 1)))
  81.         ((fx> i unit-len)
  82.          unit)
  83.       (let ((ob (vref objects (fx- i 1))))
  84.         (xselect (bref opcodes (fx- i 1))
  85.           ((op/literal)
  86.            (set (vref unit i) ob))
  87.           ((op/foreign)
  88.            (set (vref unit i)
  89.                 (cond ((mem (lambda (x y) (eq? x (foreign-object-name y)))
  90.                             ob
  91.                             (lstate-foreign *lstate*))
  92.                        => car)
  93.                       (else
  94.                        (let ((new (make-foreign-object)))
  95.                          (set (foreign-object-name new) ob)
  96.                          (push (lstate-foreign *lstate*) new)
  97.                          new)))))
  98.           ((op/closure)
  99.            (let ((new (make-templat)))
  100.              (set (templat-code-vec new) code)
  101.              (set (templat-offset new) ob)  
  102.              (set (vref unit i) new)))
  103.           ((op/template1)
  104.            (let ((new (make-cit)))
  105.              (set-template-store-slots new code ob i)
  106.              (set (vref unit i) new)))
  107.           ((op/template2) (set (vref unit i) no-op))
  108.           ((op/template3) (set (vref unit i) no-op))
  109.           ((op/vcell-stored-definition)
  110.            (let ((v (get-vcell (car ob) 'define unit i)))
  111.              (set (var-node-value (vcell-struct-var v))
  112.           (create-unit-loc unit (cdr ob)))
  113.              (set (vref unit i) v)))
  114.           ((op/vcell-defined)                
  115.            (set (vref unit i) (get-vcell ob 'define unit i)))
  116.           ((op/vcell-lset)           
  117.            (set (vref unit i) (get-vcell ob 'lset unit i)))
  118.           ((op/vcell)
  119.            (set (vref unit i) (get-vcell ob nil unit i)))
  120.           ((op/variable-value)
  121.            (set (vref unit i) (add-to-var-refs ob unit i))))))))
  122.  
  123. (define (cons-a-var-node name)
  124.   (let ((var (make-var-node))
  125.     (vcell (make-vcell-struct)))
  126.     (set (var-node-name var) name)
  127.     (set-table-entry *var-table* name var)
  128.     (set (vcell-struct-var vcell) var)
  129.     (set (var-node-vcell var) vcell)
  130.     (push *boot-env* (cons name vcell))
  131.     var))
  132.                      
  133.     
  134. (define (add-to-var-refs name unit index)
  135.   (let ((node (cond ((table-entry *var-table* name))
  136.                     (else (cons-a-var-node name)))))
  137.     (push (var-node-refs node) (cons unit (fx- index 1))) ; unit is closure
  138.     node))                                         
  139.  
  140. (define (get-vcell name definer unit index)
  141.   (let ((node (cond ((table-entry *var-table* name))
  142.                     (else (cons-a-var-node name)))))
  143.     (cond (definer                                        ; not vector
  144.            (if (var-node-defined node) (warning "~S multiply defined" name))
  145.            (set (var-node-defined node) definer)))
  146.     (push (var-node-vcell-refs node) (cons unit (fx- index 1))) ; unit is closure
  147.     (var-node-vcell node)))
  148.  
  149.  
  150. (define-constant BOOTSTRAP-SYMBOLS 
  151.   '(*boot-env* 
  152.     *the-initial-symbols* 
  153.     *the-slink*
  154.     *the-initial-modules*
  155.     *code-unit-map*))
  156.  
  157. ;;; these better not get called
  158.  
  159. (define (patch-in-definitions unit-vec code-unit-map) 
  160.   (patch '*the-initial-modules* unit-vec)
  161.   (patch '*code-unit-map* code-unit-map)
  162.   (patch '*the-slink* nil)
  163.   (patch '*the-initial-symbols* (list->vector *symbols*))
  164.   (patch '*boot-env* *boot-env*))
  165.  
  166. (define (patch name definition)
  167.   (cond ((table-entry *var-table* name)
  168.          => (lambda (node)
  169.               (and (var-node-defined node)
  170.            (warning "~S multiply defined" name))
  171.               (set (var-node-defined node) 'define)
  172.               (set (var-node-value node) definition)
  173.           (let ((desc (table-entry *reloc-table* (var-node-vcell node))))
  174.         (generate-slot-relocation definition (fx+ (heap-offset desc) 4)))
  175.           (let* ((vec (var-node-refs node))
  176.                      (size (vector-length vec)))
  177.                 (do ((i 0 (fx+ i 2)))
  178.                     ((fx>= i size))
  179.                   (generate-slot-relocation
  180.                     definition
  181.                     (fx+ (heap-offset (table-entry *reloc-table* (vref vec i))) 
  182.                          (fx* CELL (fx+ (vref vec (fx+ i 1)) 1))))))))))
  183.                     
  184.  
  185.         
  186.  
  187.  
  188. ;;; Virtual GC
  189.           
  190. (define (vgc root)
  191.   (cond ((null? root) *null-descriptor*)
  192.         ((table-entry *reloc-table* root))
  193.         (else
  194.          (allocate root))))
  195.  
  196. ;;; ALLOCATE reserves space on an appropriate heap for obj, and
  197. ;;; associates the resulting descriptor object with obj in the
  198. ;;; relocation table.  It checks all of obj's children to ensure that
  199. ;;; they have descriptors in the relocation table (and are thus
  200. ;;; allocated), and generates relocation requests for all obj's slots
  201. ;;; that contain stored descriptors.
  202.  
  203. (define (allocate obj)
  204.   ((xcond ((pair? obj) vgc-copy-pair)
  205.           ((vector? obj) vgc-copy-vector)
  206.           ((templat? obj) vgc-copy-template)
  207.           ((symbol? obj) vgc-copy-symbol)
  208.           ((bytev? obj)  vgc-copy-bytev)
  209.           ((string? obj) vgc-copy-string)
  210.           ((text? obj) vgc-copy-text)        
  211.           ((vcell-struct? obj) vgc-copy-vcell)       
  212.           ((address? obj) vgc-copy-address)
  213.           ((foreign-object? obj) vgc-copy-foreign)
  214.           ((double-float? obj) vgc-copy-double-float))
  215.    obj))
  216.  
  217. (define %%stack-size (* 512 1024))
  218.  
  219. (define (define-null-descriptor heap)
  220.   (modify (area-frontier heap)
  221.           (lambda (x) (fx+ (fx+ x %%slink-size) %%stack-size)))
  222.   (set *null-descriptor*
  223.        (object nil
  224.          ((heap-stored self) heap)
  225.          ((heap-offset self) (fx+ %%stack-size tag/pair))
  226.          ((write-descriptor self stream)
  227.           (write-data stream (fx+ %%stack-size tag/pair)))
  228.          ((write-store self stream)
  229.       (do ((i 0 (fx+ i 4)))
  230.           ((fx= i %%stack-size))
  231.         (write-int stream 0))
  232.           (let ((pi (fx+ slink/initial-pure-memory-begin 3)))
  233.             (do ((i 0 (fx+ i 4)))
  234.                 ((fx= i pi)
  235.                  (write-int stream 0)
  236.                  (write-int stream (area-frontier (lstate-pure *lstate*)))
  237.                  (write-data stream %%stack-size)
  238.                  (write-data stream (area-frontier (lstate-impure *lstate*)))
  239.                  (do ((i (fx+ i 16) (fx+ i 4)))
  240.                      ((fx= i %%slink-size))
  241.                    (write-int stream 0)))
  242.               (write-int stream 0))))))
  243.   (push (area-objects heap) *null-descriptor*)
  244.   (set-table-entry *reloc-table* nil *null-descriptor*)
  245.   (text-relocation (fx+ %%stack-size
  246.             (fx+ slink/initial-pure-memory-begin 3)))
  247.   (text-relocation (fx+ %%stack-size (fx+ slink/initial-pure-memory-end 3)))
  248.   (data-relocation (fx+ %%stack-size
  249.             (fx+ slink/initial-impure-memory-begin 3)))
  250.   (data-relocation (fx+ %%stack-size
  251.             (fx+ slink/initial-impure-memory-end 3))))
  252.  
  253.                                           
  254. (define (vgc-copy-pair pair)
  255.   (let* ((heap (lstate-impure *lstate*))
  256.          (addr (area-frontier heap))
  257.          (desc (object nil
  258.                  ((heap-stored self) (lstate-impure *lstate*))
  259.                  ((heap-offset self) addr)
  260.                  ((write-descriptor self stream)       
  261.                   (write-data stream (fx+ addr tag/pair)))
  262.                  ((write-store self stream)
  263.                   (write-slot (cdr pair) stream)
  264.                   (write-slot (car pair) stream)))))
  265.       (set (area-frontier heap) (fx+ addr (fx* CELL 2)))
  266.       (push (area-objects heap) desc)
  267.       (set-table-entry *reloc-table* pair desc)
  268.       ;;Trace from the cdr first to linearise lists
  269.       (generate-slot-relocation (cdr pair) addr)
  270.       (generate-slot-relocation (car pair) (fx+ CELL addr))
  271.       desc))
  272.  
  273. (define (vgc-copy-vector vec)
  274.   (let* ((heap (lstate-impure *lstate*))
  275.          (addr (area-frontier heap))
  276.          (nelts (vector-length vec))
  277.          (desc (object nil
  278.                  ((heap-stored self) (lstate-impure *lstate*))
  279.                  ((heap-offset self) addr)
  280.                  ((write-descriptor self stream)
  281.                   (write-data stream (fx+ addr tag/extend)))
  282.                  ((write-store self stream)
  283.                   ;;The header                                
  284.                   (let ((nelts (vector-length vec)))
  285.                     (write-int stream (fx+ (fixnum-ashl nelts 8)
  286.                                            (fx+ header/general-vector 128)))
  287.                     (dotimes (i nelts)
  288.                       (write-slot (vref vec i) stream)))))))
  289.       (set (area-frontier heap) (fx+ addr (fx+ CELL (fx* CELL nelts))))
  290.       (push (area-objects heap) desc)
  291.       (set-table-entry *reloc-table* vec desc)
  292.       (do ((i 0 (fx+ i 1))
  293.            (a (fx+ addr CELL) (fx+ a CELL)))
  294.           ((fx= i nelts))
  295.         (generate-slot-relocation (vref vec i) a))
  296.       desc))
  297.                                               
  298. (define (relocate-units the-units unit-vec)
  299.   (let* ((heap (lstate-impure *lstate*))
  300.          (begin (area-frontier heap))) 
  301.     (do ((units the-units (cdr units))
  302.          (addr begin (fx+ addr (fx* CELL (vector-length (car units))))))
  303.         ((null? units)
  304.          (set (area-frontier heap) addr)
  305.          (vgc-copy-vector unit-vec)
  306.          (walk (lambda (unit)
  307.                  (relocate-unit-1 unit))
  308.                the-units))
  309.       (let ((desc (object nil
  310.                     ((heap-stored self) (lstate-impure *lstate*))
  311.                     ((heap-offset self) addr)   
  312.                     ((write-descriptor self stream)
  313.                      (write-data stream (fx+ addr tag/extend)))
  314.                     ((write-store self stream)
  315.                      (let ((slots (fx- (vector-length (car units)) 1)))
  316.                        (write-int stream (fx+ (fixnum-ashl slots 8) 
  317.                                               header/unit))
  318.                        (do ((i 1 (fx+ i 1)))
  319.                            ((fx> i slots) t)
  320.                          (let ((ob (vref (car units) i)))
  321.                            ;;We have to special case closure-internal templates
  322.                            (cond ((cit? ob)
  323.                                   (write-template stream ob))
  324.                                  ((var-node? ob)
  325.                                   (write-var-ref stream ob))
  326.                                  ((no-op? ob))
  327.                                  (else
  328.                                   (write-slot ob stream))))))))))
  329.         (push (area-objects heap) desc)
  330.         (set-table-entry *reloc-table* (car units) desc)))))
  331.                                                                           
  332. (define (relocate-unit-1 unit)
  333.   (let* ((desc (table-entry *reloc-table* unit))
  334.          (nslots (vector-length unit)))
  335.     (do ((i 1 (fx+ i 1))
  336.          (a (fx+ (heap-offset desc) CELL) (fx+ a CELL)))
  337.         ((fx= i nslots))
  338.       (let ((ob (vref unit i)))
  339.         ;;We have to special case closure-internal templates
  340.         (cond ((cit? ob)
  341.                (generate-slot-relocation (cit-code-vec ob) 
  342.                                          (fx+ a (fx* CELL 2))
  343.                                          ))
  344.               ((no-op? ob))              
  345.               ((var-node? ob)
  346.                (relocate-unit-variable ob a nil))
  347.               (else
  348.                (generate-slot-relocation ob a)))))))
  349.  
  350. (define (vgc-copy-vcell vcell)
  351.   (let* ((heap (lstate-impure *lstate*))
  352.          (addr (area-frontier heap))
  353.          (var (vcell-struct-var vcell))
  354.          (desc (object nil
  355.                  ((heap-stored self) (lstate-impure *lstate*))
  356.                  ((heap-offset self) addr)   
  357.                  ((write-descriptor self stream)
  358.                   (write-data stream (fx+ addr tag/extend)))
  359.                  ((write-store self stream)
  360.           (write-vcell-header var stream)
  361.                   (write-var-ref stream var)
  362.                   (write-data stream (fx+ addr 22)) 
  363.                   (write-slot (var-node-name var) stream)
  364.           (write-data stream (fx+ addr 30))
  365.                   (write-int stream header/weak-alist)
  366.                   (write-slot (var-node-refs var) stream)
  367.                   (write-int stream header/weak-alist)
  368.                   (write-slot (var-node-vcell-refs var) stream)))))
  369.     (set (area-frontier heap) (fx+ addr (fx* CELL 9)))  ; 5 for vcell
  370.     (set-table-entry *reloc-table* vcell desc)          ; 4 for weak-alists
  371.     (push (area-objects heap) desc) 
  372.     (relocate-unit-variable var (fx+ addr CELL) t)
  373.     (set (var-node-refs var) (a-list->vector (var-node-refs var)))
  374.     (set (var-node-vcell-refs var) (a-list->vector (var-node-vcell-refs var)))
  375.     (generate-slot-relocation (var-node-refs var) (fx+ addr (fx* CELL 6)))
  376.     (generate-slot-relocation (var-node-vcell-refs var) (fx+ addr (fx* CELL 8)))
  377.     (generate-slot-relocation (var-node-name var) (fx+ addr (fx* CELL 3)))
  378.     (data-relocation (fx+ addr (fx* CELL 2)))
  379.     (data-relocation (fx+ addr (fx* CELL 4)))
  380.     desc))
  381.                                                                   
  382. (define (a-list->vector a)
  383.   (let ((vec (make-vector (fx* (length a) 2))))
  384.     (do ((i 0 (fx+ i 2))
  385.          (a a (cdr a)))
  386.         ((null? a) vec)
  387.       (set (vref vec i) (caar a))
  388.       (set (vref vec (fx+ i 1)) (cdar a)))))
  389.  
  390. (define (vgc-copy-template tmplt)
  391.   (let* ((cv (vgc (templat-code-vec tmplt)))
  392.          (desc (object nil
  393.                  ((heap-stored self) (lstate-pure *lstate*))
  394.                  ((write-descriptor self stream)
  395.                   (write-int stream (fx+ (templat-offset tmplt)
  396.                                          (fx+ (heap-offset cv) CELL)))))))
  397.     (set-table-entry *reloc-table* tmplt desc)
  398.     desc))
  399.  
  400. (define (vgc-copy-symbol sym)
  401.   (push *symbols* sym)
  402.   (let* ((heap (lstate-pure *lstate*))
  403.          (addr (area-frontier heap))
  404.          (end-addr (fx+ CELL (fx+ addr (symbol-length sym))))
  405.          (desc (object nil
  406.                  ((heap-stored self) (lstate-pure *lstate*))
  407.                  ((heap-offset self) addr)
  408.                  ((write-descriptor self stream)
  409.                   (write-int stream (fx+ (heap-offset self) tag/extend)))
  410.                  ((write-store self stream)
  411.                   (let ((len (symbol-length sym)))
  412.                     (write-int stream (fx+ (fixnum-ashl len 8)
  413.                                            (fx+ header/symbol 128)))
  414.                     (write-fixnum stream (symbol-hash sym))
  415.                     (write-block stream sym %%symbol-text-offset len)
  416.                     (dotimes (i (fx- (align len 2) len))
  417.                       (write-byte stream 0)))))))
  418.     (set (area-frontier heap) (align end-addr 2))
  419.     (push (area-objects heap) desc)
  420.     (set-table-entry *reloc-table* sym desc)
  421.     desc))
  422.                                                                                   
  423. (define (vgc-copy-bytev vec)
  424.   (vgc-copy-bytes vec (bytev-length vec) header/bytev))
  425.  
  426. (define (vgc-copy-text text) 
  427.   (vgc-copy-bytes text (text-length text) header/text))
  428.  
  429. (define (vgc-copy-bytes bytes vlen header)
  430.   (let* ((heap (lstate-pure *lstate*))
  431.          (addr (area-frontier heap))
  432.          (end-addr (fx+ CELL (fx+ addr vlen)))
  433.          (desc (object nil
  434.                  ((heap-stored self) (lstate-pure *lstate*))
  435.                  ((heap-offset self) addr)    
  436.                  ((write-descriptor self stream)
  437.                   (write-int stream (fx+ addr tag/extend)))
  438.                  ((write-store self stream)           
  439.                   (let ((vlen (bytev-length bytes)))
  440.                     (write-int stream (fx+ (fixnum-ashl vlen 8)
  441.                                            (fx+ header 128)))
  442.                     (write-block stream bytes 0 vlen)
  443.                     ;;Pad to the next cell boundary.
  444.                     (dotimes (i (fx- (align vlen 2) vlen))
  445.                       (write-byte stream 0)))))))
  446.     (set (area-frontier heap) (align end-addr 2))
  447.     (push (area-objects heap) desc)
  448.     (set-table-entry *reloc-table* bytes desc)
  449.     desc))
  450.  
  451. (define (vgc-copy-string str)
  452.   (let* ((heap (lstate-impure *lstate*))
  453.          (addr (area-frontier heap))
  454.          (text (string-text str)) 
  455.          (desc (object nil
  456.                  ((heap-stored self) (lstate-impure *lstate*))
  457.                  ((heap-offset self) addr)
  458.                  ((write-descriptor self stream)
  459.                   (write-data stream (fx+ addr tag/extend)))
  460.                  ((write-store self stream)
  461.                   (write-int stream (fx+ (fixnum-ashl (text-length text) 8)
  462.                                          header/slice))
  463.                   (write-slot text stream)
  464.                   (write-int stream 0)))))       ;; offset
  465.     (set (area-frontier heap) (fx+ addr (fx* CELL 3)))
  466.     (set-table-entry *reloc-table* str desc)
  467.     (push (area-objects heap) desc)
  468.     (generate-slot-relocation text (fx+ addr CELL))
  469.     desc))                    
  470.  
  471. (define (write-var-ref stream var)
  472.   (cond ((neq? (var-node-value var) NONVALUE)
  473.          (let ((value (var-node-value var)))
  474.             (if (unit-loc? value)
  475.                 (write-unit-loc stream value)
  476.                 (write-slot value stream))))
  477.         (else
  478.          (write-int stream header/nonvalue))))
  479.                                                      
  480. ;;; Flonum dismemberment.
  481.  
  482. ;;; Returns sign, and normalized mantissa and exponent  
  483. ;;; PRECISION is number of bits desired in the mantissa 
  484. ;;; EXCESS is the exponent excess
  485. ;;; HIDDEN-BIT-IS-1.? is true if the hidden bit preceeds the
  486. ;;;  binary point (it does in Apollo IEEE, does not on the VAX).
  487.  
  488. (define (normalized-float-parts flonum precision excess hidden-bit-is-1.?)
  489.     (cond ((fl= flonum 0.0)
  490.            (return 0 (%ash 1 (fx+ precision 1)) 0))
  491.           (else
  492.            (receive (#f m e) (integer-decode-float flonum)
  493.               (let* ((have (integer-length m))
  494.                      (need (fx- precision have))
  495.                      (normalized-m (%ash m need))
  496.                      (normalized-e (- (+ e 
  497.                                          precision 
  498.                                          excess
  499.                                          (if hidden-bit-is-1.? -1 0))
  500.                                        need)))
  501.                  (return (if (fl< flonum 0.0) 1 0) normalized-m normalized-e))))))
  502.  
  503. (define (vgc-copy-double-float float)
  504.   (let* ((heap (lstate-pure *lstate*))
  505.          (addr (area-frontier heap))
  506.          (desc (object nil
  507.                  ((heap-stored self) (lstate-pure *lstate*))
  508.                  ((heap-offset self) addr)
  509.                  ((write-descriptor self stream)
  510.                   (write-int stream (fx+ addr tag/extend)))
  511.                  ((write-store self stream)
  512.                   (write-double-float stream float)))))
  513.     (set (area-frontier heap) (fx+ addr (fx* CELL 3)))
  514.     (set-table-entry *reloc-table* float desc)
  515.     (push (area-objects heap) desc)
  516.     desc))                    
  517.                                                           
  518. ;;; Floating point bit fields.
  519.  
  520. ;;; <n,s> means bit field of length s beginning at bit n of the first
  521. ;;; WORD (not longword)
  522. ;;;                    sign      exponent   MSB       fraction
  523. ;;; Apollo IEEE flonum <15,1>    <4,11>     hidden    <0,4>+next 3 words
  524. ;;; VAX11 flonum (D)   <15,1>    <7,8>      hidden    <0,7>+next 3 words
  525. ;;; Apollo IEEE flonum - binary point follows  hidden MSB, 53 bits of
  526. ;;;     precision, if hidden bit is included
  527. ;;; VAX11 flonum (D)   - binary point precedes hidden MSB, 56 bits of
  528. ;;;     precision, if hidden bit is included 
  529.  
  530.  
  531. (define (write-block port obj start len)
  532.   (let ((writec (if (iob? port) vm-write-char write-char)))
  533.     (do ((i start (fx+ i 1)))
  534.         ((fx>= i len))
  535.       (writec port (text-elt obj i)))))
  536.  
  537.  
  538. (define (write-unit-loc stream u)
  539.   (write-data stream (fx+ (heap-offset (table-entry *reloc-table* (unit-loc-unit u)))
  540.                          (fx+ tag/extend
  541.                               (unit-loc-offset u)))))
  542.  
  543. (define (unit-var-value value)
  544.   (if (unit-loc? value)
  545.       (fx+ (heap-offset (table-entry *reloc-table* (unit-loc-unit value)))
  546.            (fx+ (unit-loc-offset value) tag/extend))
  547.       (heap-offset (table-entry *reloc-table* value))))
  548.  
  549. (define-integrable (align n m)
  550.   (let ((2^m-1 (fx- (fixnum-ashl 1 m) 1)))
  551.     (fixnum-logand (fx+ n 2^m-1) (fixnum-lognot 2^m-1))))
  552.  
  553. (define-operation (heap-stored obj))
  554. (define-operation (heap-offset obj))           
  555. (define-operation (write-descriptor obj stream))
  556. (define-operation (write-store obj stream))
  557.